home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / mrgsort.zip / MRGDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1990-04-18  |  6KB  |  199 lines
  1. {$A-,B-,D+,E+,F-,I+,L+,N-,O-,R+,S+,V+}
  2. {$M 2048,0,655360}
  3.  
  4. PROGRAM mrgdemo(input, output);         (* compiled on TP5.0 *)
  5. (* Demonstrating the use of mergesort on linked lists        *)
  6. (* We are using a packed representation of the A..Z alphabet *)
  7. (* This is based on Sedgewicks (Algorithms) descriptions.    *)
  8. (* You can easily get to 20 or 30000 items.  This demo will  *)
  9. (* only create about 180 items with the heap limit at 6000.  *)
  10.  
  11. (* Public Domain, by C.B. Falconer, 1:141/209.1@fidonet      *)
  12. (* {} at left margin marks non-std portability problems.     *)
  13. (* Any others should be resolvable by creating procs/types   *)
  14.  
  15. (* On my 8mhz V20 XT system, executes as follows:            *)
  16. (*        items      creation time      sorting time         *)
  17. (*        -----      -------------      ------------         *)
  18. (*           10        0.013 Sec.         0.010 Sec.         *)
  19. (*          100        0.117 Sec.         0.164 Sec.         *)
  20. (*          500        0.582 Sec.         1.050 Sec.         *)
  21. (*         2500        2.903 Sec.         6.407 Sec.         *)
  22. (*        12500       14.502 Sec.        38.028 Sec.         *)
  23. (* (FULL) 33874       38.028 Sec.       113.692 Sec.         *)
  24. (* which shows the n*log(n) behaviour of the algorithm.      *)
  25.  
  26. {}USES  (* all public domain *)
  27. {}  txtfiles,       (* for fptr, skipblks, readwd *)
  28. {}  uclock,         (* for clock, microsecond timing *)
  29. {}  errmsgs,        (* for full runtime error display *)
  30. {}  mrgsort;        (* for sort, greaterf, null *)
  31.  
  32.   CONST
  33.     minchar       = 'A';
  34.     maxchar       = 'Z';   (* underlying continuous char set assumed *)
  35.     packing       = 3;     (* chars per packed word *)
  36.     pksize        = 4;
  37.     alfalen       = 12;    (* (packing * pksize), ref. only *)
  38.     maxword       = 65535;
  39.  
  40.   TYPE
  41.     pkword        = integer;
  42.     pkindex       = 1..pksize;
  43.  
  44.     alfaptr       = ^alfa;
  45.     alfa          = RECORD        (* must agree with link in mrgsort *)
  46.       next          : alfaptr;    (* i.e. this MUST be first field   *)
  47.       index         : word;
  48.       s             : ARRAY[pkindex] OF pkword;
  49.       END; (* alfa *)
  50.  
  51.   VAR
  52.     root          : alfaptr;   (* of the monster list *)
  53.     chrmax        : integer;   (* handy size of char coding *)
  54.     maxcount      : word;      (* how big to make the list *)
  55.     begun,
  56.     ended         : real;      (* for routine timing only *)
  57.  
  58. {}  relation      : greaterf;  (* TP can't pass procedures, only ptrs *)
  59.  
  60.   (* 1---------------1 *)
  61.  
  62.   PROCEDURE buildlist(root : alfaptr);
  63.  
  64.     CONST
  65.       margin  = 2048;
  66.  
  67.     VAR
  68.       j,
  69.       pkmax   : integer;
  70.       count   : word;
  71.  
  72.     BEGIN (* buildlist *)
  73.     pkmax := succ(chrmax) * succ(chrmax) * succ(chrmax);
  74.     count := 0;
  75.     WHILE (memavail > margin) AND (count < maxcount) DO BEGIN
  76.       new(root^.next); root := root^.next; root^.next := null;
  77.       count := succ(count); root^.index := count;
  78.       FOR j := 1 TO pksize DO root^.s[j] := random(pkmax); END;
  79.     ended := clock;
  80.     IF memavail <= margin THEN write('(FULL) ');
  81.     write(count : 1, ' items created');
  82.     END; (* buildlist *)
  83.  
  84.   (* 1---------------1 *)
  85.  
  86.   PROCEDURE dump(items : alfaptr);
  87.  
  88.     VAR
  89.       n    : word;
  90.  
  91.     (* 2---------------2 *)
  92.  
  93.     PROCEDURE dump12;
  94.  
  95.       VAR
  96.         j   : pkindex;
  97.  
  98.       (* 3---------------3 *)
  99.  
  100.       PROCEDURE dump3(w : pkword);
  101.  
  102.         VAR
  103.           i      : 1..packing;
  104.           ch     : ARRAY[1..packing] OF char;
  105.  
  106.         BEGIN (* dump3 *)
  107.         FOR i := 1 TO packing DO BEGIN
  108.           ch[i] := chr(w MOD succ(chrmax));
  109.           w := w DIV succ(chrmax); END;
  110.         FOR i := packing DOWNTO 1 DO
  111.           write(chr(ord(ch[i]) + ord(minchar)));
  112.         END; (* dump3 *)
  113.  
  114.       (* 3---------------3 *)
  115.  
  116.       BEGIN (* dump12 *)
  117.       write(n : 6, ' ', items^.index : 6, ' ');
  118.       FOR j := pksize DOWNTO 1 DO dump3(items^.s[j]);
  119.       END; (* dump12 *)
  120.  
  121.     (* 2---------------2 *)
  122.  
  123.     BEGIN (* dump *)
  124.     n := 0;
  125.     WHILE items <> null DO BEGIN
  126.       n := succ(n); dump12; items := items^.next;
  127.       IF n MOD 3 = 0 THEN writeln; END;
  128.     IF n MOD 3 <> 0 THEN writeln;
  129.     END; (* dump *)
  130.  
  131.   (* 1---------------1 *)
  132.  
  133.   FUNCTION gety(prompt : string) : boolean;
  134.   (* true if user enters 'y' or 'Y', else false *)
  135.  
  136.     BEGIN (* gety *)
  137.     write(prompt); skipblks(input);
  138.     IF eoln THEN gety := false
  139.     ELSE gety := upcase(fptr(input)) = 'Y';
  140.     readln;
  141.     END; (* gety *)
  142.  
  143.   (* 1---------------1 *)
  144.  
  145. {$f+}   (* passed functions MUST be far *)
  146.  
  147.   FUNCTION greater(thing, than : pointer) : boolean;
  148.   (* This is the time bind - make assy language. This *)
  149.   (* will later be passed in as a param to mrgsort    *)
  150.   
  151.     LABEL 9, 10;
  152.   
  153.     VAR
  154.       k    : pkindex;
  155.              (* These gyrations bypass type checking, and describe  *)
  156.              (* the actual pointer type that mrgsort will call with *)
  157. {}    a    : alfaptr ABSOLUTE thing;
  158. {}    b    : alfaptr ABSOLUTE than;
  159. {$r-,s-}
  160.     BEGIN (* greater *)
  161.     greater := true;
  162.     FOR k := pksize DOWNTO 1 DO  (* Check most sig. first *)
  163.       IF a^.s[k] > b^.s[k] THEN GOTO 10
  164.       ELSE IF a^.s[k] < b^.s[k] THEN GOTO 9;
  165.  9: greater := false;
  166. 10: END; (* greater *)
  167.  
  168. {$r+,s+,f-}      (* put the options back *)
  169.  
  170.   (* 1---------------1 *)
  171.  
  172.   BEGIN (* mrgdemo *)
  173. {}relation := greater;           (* init the procedural pointer *)
  174.   new(root); root^.next := null;             (* using sentinels *)
  175.   chrmax := ord(maxchar) - ord(minchar);  (* randomize; *)
  176.  
  177.   REPEAT
  178.     write('How many items to create (5 min) ? ');
  179.     readwd(input, maxcount); readln;
  180.   UNTIL maxcount >= 5;
  181.  
  182.   write('Building ... ');
  183.   begun := clock;
  184.   buildlist(root);          (* just to create something to sort *)
  185.   ended := clock;
  186.   writeln(' in ', (ended - begun) * 3600 : 1 : 3, ' seconds');
  187.   IF gety('Dump list (y/N) ?') THEN dump(root^.next);
  188.  
  189.   write('Sorting ... ');
  190.   begun := clock;
  191.  
  192.   (* Here we do all the real work *)
  193.   root^.next := sort(root^.next, relation);
  194.  
  195.   ended := clock;
  196.   writeln(' done in ', (ended - begun) * 3600 : 1 : 3, ' seconds');
  197.   IF gety('Dump list (y/N) ?') THEN dump(root^.next);
  198.   END. (* mrgdemo *)
  199. «.